{-# LANGUAGE TypeFamilies, TemplateHaskell, ViewPatterns #-}

{- |

Module      :  Type.Yoko.Wrapper
Copyright   :  (c) The University of Kansas 2011
License     :  BSD3

Maintainer  :  nicolas.frisby@gmail.com
Stability   :  experimental
Portability :  see LANGUAGE pragmas (... GHC)

The @Wrapper@ class is used to make term-level programming @newtype@s a little
more lightweight from the user perspective.

-}

module Type.Yoko.Wrapper where

import Language.Haskell.TH

import Type.Spine.TH (tvb_kind)

__varD n e = valD (varP n) (normalB e) []


type family Unwrap (f :: * -> *) a

-- | The @Wrapper@ class is used to make term-level programming @newtype@s a
-- little more lightweight from the user perspective.
class Wrapper f where wrap :: Unwrap f a -> f a; unwrap :: f a -> Unwrap f a

-- | A type /wraps trivially/ if its @wrap@ and @unwrap@ are both @id@.
wraps_trivially :: Name -> Q [Dec]
wraps_trivially n = do
  i <- reify n
  let bad :: Q a
      bad = fail "`wraps_trivially' expects the name of a data or newtype with at least one argument and its last argument is a * "
  tvbs <- case i of
    TyConI dec -> case dec of
      DataD _ _ tvbs _ _ -> return tvbs
      NewtypeD _ _ tvbs _ _ -> return tvbs
      _ -> bad
    _ -> bad
  case tvbs of
    [] -> bad
    ((tvb_kind . last) -> StarK) -> return ()
    _ -> bad
  let ns = map tvb_name tvbs where
        tvb_name (PlainTV n) = n; tvb_name (KindedTV n _) = n
      tss = foldl (\t n -> t `appT` varT n) (conT n) (init ns)

  nt <- newName "t"

  ds <- do
    x <- 'wrap `__varD` [|id|]
    y <- 'unwrap `__varD` [|id|]
    return [x, y]
  sequence [
    tySynInstD ''Unwrap [tss, varT nt] [t|$tss $(varT nt)|],
    instanceD (return []) (conT ''Wrapper `appT` tss) (map return ds)
    ]

-- | A type wraps trivially if its @wrap@ and @unwrap@ simply manage its
-- @newtype@ isomorphism.
wraps_thinly :: Name -> Q [Dec]
wraps_thinly n = do
  i <- reify n
  let bad :: Q a
      bad = fail "`wraps_thinly' expects the name of a data or newtype with at least one argument and its last argument is a *, and exactly one constructor with exactly one field"
  (tvbs, con) <- case i of
    TyConI dec -> case dec of
      DataD _ _ tvbs [con] _ -> return (tvbs, con)
      NewtypeD _ _ tvbs con _ -> return (tvbs, con)
      _ -> bad
    _ -> bad
  nt <- case tvbs of
    [] -> bad
    ((tvb_kind . last) -> StarK) -> return $ tvb_name $ last tvbs
      where tvb_name (PlainTV n) = n; tvb_name (KindedTV n _) = n
    _ -> bad
  (cn, fdty) <- case con of
    NormalC n [(_, t)] -> return (n, t)
    RecC n [(_, _, t)] -> return (n, t)
    _ -> bad
  let ns = map tvb_name tvbs where
        tvb_name (PlainTV n) = n; tvb_name (KindedTV n _) = n
      tss = foldl (\t n -> t `appT` varT n) (conT n) (init ns)

  nx <- newName "x"

  ds <- do
    x <- 'wrap `__varD` conE cn
    y <- 'unwrap `__varD` lamE [conP cn [varP nx]] (varE nx)
    return [x, y]
  sequence [
    tySynInstD ''Unwrap [tss, varT nt] (return fdty),
    instanceD (return []) (conT ''Wrapper `appT` tss) (map return ds)
    ]
